home *** CD-ROM | disk | FTP | other *** search
- /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
-
- /*
- $Header: b3in2.c,v 1.4 85/08/22 16:58:21 timo Exp $
- */
-
- /* B interpreter -- independent subroutines */
-
- #include "b.h"
- #include "b1obj.h"
- #include "b3env.h"
- #include "b3in2.h"
- #include "b3sem.h"
- #include "b3sou.h"
-
- /* Making ranges */
-
- Hidden value c_range(lo, hi) value lo, hi; {
- char a, z;
- if (!character(lo))
- error(MESS(3400, "in {p..q}, p is a text but not a character"));
- else if (!Is_text(hi))
- error(MESS(3401, "in {p..q}, p is a text, but q is not"));
- else if (!character(hi))
- error(MESS(3402, "in {p..q}, q is a text, but not a character"));
- else {
- a= charval(lo); z= charval(hi);
- if (z < a-1) error(MESS(3403, "in {p..q}, character q < x < p"));
- else return mk_charrange(lo, hi);
- }
- return Vnil;
- }
-
- Hidden value i_range(lo, hi) value lo, hi; {
- value entries, res= Vnil;
- if (!integral(lo))
- error(MESS(3404, "in {p..q}, p is a number but not an integer"));
- else if (!Is_number(hi))
- error(MESS(3405, "in {p..q}, p is a number but q is not"));
- else if (!integral(hi))
- error(MESS(3406, "in {p..q}, q is a number but not an integer"));
- else {
- entries= diff(lo, hi);
- if (compare(entries, one)>0)
- error(MESS(3407, "in {p..q}, integer q < x < p"));
- else res= mk_numrange(lo, hi);
- release(entries);
- }
- return res;
- }
-
- Visible value mk_range(v1, v2) value v1, v2; {
- value r= Vnil;
- if (Is_text(v1)) r= c_range(v1, v2);
- else if (Is_number(v1)) r= i_range(v1, v2);
- else error(MESS(3408, "in {p..q}, p is neither a text nor a number"));
- return r;
- }
-
-
- /* Newlines for WRITE /// */
-
- Visible Procedure nl(n) value n; {
- value l= size(n); int c= intval(l); release(l);
- while (c--) newline();
- }
-
-
- /* Evaluating basic targets */
-
- Visible value v_local(name, number) value name, number; {
- value *aa= envassoc(curnv->tab, number);
- if (aa != Pnil && *aa != Vnil) return copy(*aa);
- error3(0, name, MESS(3409, " has not yet received a value"));
- return Vnil;
- }
-
- Visible value v_global(name) value name; {
- value *aa= envassoc(prmnv->tab, name);
- if (aa != Pnil && *aa != Vnil) return copy(tarvalue(name, *aa));
- error3(0, name, MESS(3410, " has not yet received a value"));
- return Vnil;
- }
-
-
- /* Locating mysteries */
-
- Visible loc l_mystery(name, number) value name, number; {
- if (Is_compound(curnv->tab)) return local_loc((basidf) number);
- return global_loc(name);
- }
-
-
- /* Rangers */
-
- /* An IN-ranger is represented on the stack as a compound of three fields:
- the last index used, the value of the expression after IN, and its length.
- (The latter is redundant, but saves save many calls of 'size()'.)
- When first called, there is, of course, no compound on the stack, but only
- the value of the expression. As the expression should always be a text,
- list or table, this is recognizable as a special case, and then the
- compound is created.
- Return value is Yes if a new element was available and assigned, No if not.
- */
-
- Visible bool in_ranger(l, pv) loc l; value *pv; {
- value v= *pv, ind, tlt, len, i1, val; bool res;
- if (!Is_compound(v) || Nfields(v) != 3) { /* First time */
- tlt= v;
- if (!Is_tlt(tlt)) {
- error(MESS(3411, "in ... i IN e, e is not a text, list or table"));
- return No;
- }
- if (empty(tlt)) return No;
- *pv= v= mk_compound(3);
- *Field(v, 0)= ind= one;
- *Field(v, 1)= tlt;
- *Field(v, 2)= len= size(tlt);
- bind(l);
- }
- else {
- ind= *Field(v, 0); tlt= *Field(v, 1); len= *Field(v, 2);
- res= numcomp(ind, len) < 0;
- if (!res) { unbind(l); return No; }
- *Field(v, 0)= ind= sum(i1= ind, one); release(i1);
- }
- put(val= th_of(ind, tlt), l); release(val);
- return Yes;
- }
-
-
- /* PARSING-rangers are treated similarly to IN-rangers, but here the
- compound contains the last parse (i.e., N texts). */
-
- Visible bool pa_ranger(l, pv) loc l; value *pv; {
- value v= *pv, e, f; int len, k;
- if (!Is_compound(v)) {
- if (!Is_text(v)) {
- error(MESS(3412, "in ... i PARSING e, e is not a text"));
- return No;
- }
- if (!Is_compound(l)) {
- error(
- MESS(3413, "in ... i PARSING e, i is not a collateral identifier"));
- return No;
- }
- v= mk_compound(len= Nfields(l));
- *Field(v, len-1)= *pv;
- *Field(v, 0)= e= mk_text("");
- for (k= 1; k < len-1; ++k)
- *Field(v, k)= copy(e);
- *pv= v;
- bind(l);
- put(v, l);
- return Yes;
- }
- uniql(pv); v= *pv;
- len= Nfields(v);
- for (k= len-1; k > 0; --k) {
- if (!empty(f= *Field(v, k))) {
- value head, tail, prev, newprev, two= sum(one, one);
- head= curtail(f, one); tail= behead(f, two);
- release(f);
- newprev= concat(prev= *Field(v, k-1), head);
- release(prev); release(head);
- *Field(v, k-1)= newprev;
- if (k < len-1)
- *Field(v, k)= *Field(v, len-1);
- *Field(v, len-1)= tail;
- put(v, l);
- return Yes;
- }
- }
- unbind(l);
- return No;
- }
-